home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / schmlbrr / schem_lb.lha / unsupported / CScheme / scoops-7.0.scm.‾1‾ < prev    next >
Encoding:
Text File  |  1993-07-16  |  38.6 KB  |  1,183 lines
  1. ;;;
  2. ;;;    Copyright (c) 1986 Texas Instruments Incorporated
  3. ;;;
  4. ;;;    Permission to copy this software, to redistribute it, and
  5. ;;;     to use it for any purpose is granted, subject to the
  6. ;;;     following restrictions and understandings.
  7. ;;;
  8. ;;;    1. Any copy made of this software must include this copyright
  9. ;;;    notice in full.
  10. ;;;
  11. ;;;    2.  All materials developed as a consequence of the use of
  12. ;;;    this software shall duly acknowledge such use, in accordance
  13. ;;;    with the usual standards of acknowledging credit in academic
  14. ;;;    research.
  15. ;;;
  16. ;;;    3. TI has made no warranty or representation that the
  17. ;;;    operation of this software will be error-free, and TI is
  18. ;;;    under no obligation to provide any services, by way of
  19. ;;;    maintenance, update, or otherwise.
  20. ;;;
  21. ;;;    4.  In conjunction with products arising from the use
  22. ;;;    of this material, there shall be no use of the name of
  23. ;;;     Texas Instruments (except for the above copyright credit)
  24. ;;;    nor of any adaptation thereof in any advertising, promotional,
  25. ;;;     or sales literature without prior written consent from TI in
  26. ;;;     each case.
  27. ;;;
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29.  
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31. ;;;                                                                 ;;;
  32. ;;;                     S c o o p s                                 ;;;
  33. ;;;                                                                 ;;;
  34. ;;;               File updated : 5/23/86                            ;;;
  35. ;;;                                                                 ;;;
  36. ;;;                   File : class.scm                              ;;;
  37. ;;;                                                                 ;;;
  38. ;;;                 Amitabh Srivastava                              ;;;
  39. ;;;                                                                 ;;;
  40. ;;;         This file handles class creation.                       ;;;
  41. ;;;                                                                 ;;;
  42. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43.  
  44. (declare (usual-integrations))
  45.  
  46. (define ALL-CLASSVARS)
  47. (define ALL-INSTVARS)
  48. (define ALL-METHODS)
  49. (define CLASS-COMPILED?)
  50. (define CLASSVARS)
  51. (define DESCRIBE)
  52. (define INSTVARS)
  53. (define METHODS)
  54. (define MIXINS)
  55.  
  56. ;;; These definitions are to bring scoops up to date with MIT Scheme 7.0
  57.  
  58. (define make-interned-symbol intern)
  59. (define parser-package (->environment (find-package '(runtime parser))))
  60. (define unparser-package (->environment (find-package '(runtime unparser))))
  61. (define environment-package (->environment
  62.                  (find-package '(runtime environment))))
  63. (define mapcar map)
  64. (define (putprop object data key) (2d-put! object key data))
  65. (define getprop 2d-get)
  66. (define (writeln . objects)
  67.   (newline)
  68.   (for-each display objects))
  69. (define breakpoint bkpt)
  70. (define string->symbol intern)
  71.  
  72. (define-macro (rec name lambda-exp)
  73.   `(begin (define ,name ,lambda-exp) ,name))
  74.  
  75. (define-macro (apply-if exp cons-proc alt-thunk)
  76.   `(cond (,exp => ,cons-proc)
  77.      (else (,alt-thunk))))
  78.  
  79. ;;;
  80.  
  81. (define %%class-tag (make-interned-symbol "#!CLASS"))
  82.  
  83. (set! (access named-objects parser-package) 
  84.       (cons (cons 'CLASS %%class-tag) (access named-objects parser-package)))
  85.  
  86.  
  87. ((access add-unparser-special-object! unparser-package) %%class-tag
  88.  (lambda (class)
  89.    ((access unparse-with-brackets unparser-package)
  90.     (lambda ()
  91.       (write-string "SCOOPS Class ")
  92.       (write (hash class))))))
  93.  
  94.  
  95. (define %sc-make-class
  96.   (lambda (name cv allivs mixins method-values)
  97.     (let ((method-structure
  98.                   (mapcar (lambda (a) (list (car a) (cons name name)))
  99.                           method-values))
  100.           (class (make-vector 15)))
  101.        (vector-set! class 0 %%class-tag)
  102.        (vector-set! class 1 name)
  103.        (vector-set! class 2 cv)
  104.        (vector-set! class 3 cv)
  105.        (vector-set! class 4 allivs)
  106.        (vector-set! class 5 mixins)
  107.        (vector-set! class 6 (%uncompiled-make-instance class))
  108.        (vector-set! class 9 method-structure)
  109.        (vector-set! class 13 method-values)
  110.        (vector-set! class 14 allivs)
  111.        (putprop name class '%class)
  112.        class)))
  113.  
  114. (define %scoops-chk-class
  115.   (lambda (class)
  116.     (and (not (and (vector? class)
  117.                    (> (vector-length class) 0)
  118.                    (equal? %%class-tag (vector-ref class 0))))
  119.          (error-handler class 6 #!TRUE))))
  120.  
  121.  
  122. ;;; %sc-name
  123. (define-integrable (%sc-name class)
  124.     (vector-ref class 1))
  125.  
  126. ;;; %sc-cv
  127. (define-integrable (%sc-cv class)
  128.     (vector-ref class 2))
  129.  
  130. ;;; %sc-allcvs
  131. (define-integrable (%sc-allcvs class)
  132.     (vector-ref class 3))
  133.  
  134. ;;; %sc-allivs
  135. (define-integrable (%sc-allivs class)
  136.     (vector-ref class 4))
  137.  
  138. ;;; %sc-mixins
  139. (define-integrable (%sc-mixins class)
  140.     (vector-ref class 5))
  141.  
  142. ;;; %sc-inst-template
  143. (define-integrable (%sc-inst-template class)
  144.     (vector-ref class 6))
  145.  
  146. ;;; %sc-method-env
  147. (define-integrable (%sc-method-env class)
  148.     (vector-ref class 7))
  149.  
  150. ;;; %sc-class-env
  151. (define-integrable (%sc-class-env class)
  152.     (vector-ref class 8))
  153.  
  154.  
  155. ;;; %sc-method-structure
  156. (define-integrable (%sc-method-structure class)
  157.     (vector-ref class 9))
  158.  
  159. ;;; %sc-subclasses
  160. (define-integrable (%sc-subclasses class)
  161.     (vector-ref class 10))
  162.  
  163. ;;; %sc-class-compiled
  164. (define-integrable (%sc-class-compiled class)
  165.     (vector-ref class 11))
  166.  
  167. ;;; %sc-class-inherited
  168. (define-integrable (%sc-class-inherited class)
  169.     (vector-ref class 12))
  170.  
  171. ;;; %sc-method-values
  172. (define-integrable (%sc-method-values class)
  173.     (vector-ref class 13))
  174.  
  175. (define-integrable (%sc-iv class)
  176.     (vector-ref class 14))
  177.  
  178. ;;; %sc-set-name
  179. (define-integrable (%sc-set-name class val)
  180.     (vector-set! class 1 val))
  181.  
  182. ;;; %sc-set-cv
  183. (define-integrable (%sc-set-cv class val)
  184.     (vector-set! class 2 val))
  185.  
  186.  
  187. ;;; %sc-set-allcvs
  188. (define-integrable (%sc-set-allcvs class val)
  189.     (vector-set! class 3 val))
  190.  
  191. ;;; %sc-set-allivs
  192. (define-integrable (%sc-set-allivs class val)
  193.     (vector-set! class 4 val))
  194.  
  195. ;;; %sc-set-mixins
  196. (define-integrable (%sc-set-mixins class val)
  197.     (vector-set! class 5 val))
  198.  
  199. ;;; %sc-set-inst-template
  200. (define-integrable (%sc-set-inst-template class val)
  201.     (vector-set! class 6 val))
  202.  
  203. ;;; %sc-set-method-env
  204. (define-integrable (%sc-set-method-env class val)
  205.     (vector-set! class 7 val))
  206.  
  207. ;;; %sc-set-class-env
  208. (define-integrable (%sc-set-class-env class val)
  209.     (vector-set! class 8 val))
  210.  
  211. ;;; %sc-set-method-structure
  212. (define-integrable (%sc-set-method-structure class val)
  213.     (vector-set! class 9 val))
  214.  
  215. ;;; %sc-set-subclasses
  216. (define-integrable (%sc-set-subclasses class val)
  217.     (vector-set! class 10 val))
  218.  
  219.  
  220. ;;; %sc-set-class-compiled
  221. (define-integrable (%sc-set-class-compiled class val)
  222.     (vector-set! class 11 val))
  223.  
  224. ;;; %sc-set-class-inherited
  225. (define-integrable (%sc-set-class-inherited class val)
  226.     (vector-set! class 12 val))
  227.  
  228. ;;; %sc-set-method-values
  229. (define-integrable (%sc-set-method-values class val)
  230.     (vector-set! class 13 val))
  231.  
  232. ;;; %sc-set-iv
  233. (define-integrable (%sc-set-iv class val)
  234.     (vector-set! class 14 val))
  235.  
  236.  
  237. ;;;
  238. (define %sc-name->class
  239.   (lambda (name)
  240.     (apply-if (getprop name '%class)
  241.               (lambda (a) a)
  242.               (error-handler name 2 #!TRUE))))
  243.  
  244. ;;; %sc-get-meth-value
  245. (define-integrable (%sc-get-meth-value meth-name class)
  246.     (cdr (assq meth-name (%sc-method-values class))))
  247.  
  248. ;;; %sc-get-cv-value
  249. (define-integrable (%sc-get-cv-value var class)
  250.     (cadr (assq var (%sc-cv class))))
  251.  
  252. ;;; %sc-concat
  253. (define-integrable (%sc-concat str sym)
  254.     (string->symbol (string-append str (symbol->string sym))))
  255.  
  256.  
  257. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  258. ;;;                                                                 ;;;
  259. ;;;                     S c o o p s                                 ;;;
  260. ;;;                                                                 ;;;
  261. ;;;                                                                 ;;;
  262. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  263. ;;;        by Steve Sherin--U of P                    ;;;
  264. ;;;                   File : methods.scm                            ;;;
  265. ;;;                                                                 ;;;
  266. ;;;                 Amitabh Srivastava                              ;;;
  267. ;;;                                                                 ;;;
  268. ;;;    This file handles the addition/redefinition of methods.      ;;;
  269. ;;;                                                                 ;;;
  270. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  271.  
  272.  
  273. ;;; is class1 before class2 in class ?
  274. ;;; class1  is not equal to class2
  275.  
  276. (define %before
  277.   (lambda (class1 class2 class)
  278.     (or (eq? class1 class)
  279.         (memq class2 (memq class1 (%sc-mixins (%sc-name->class class)))))))
  280.  
  281. ;;; DEFINE-METHOD
  282. (syntax-table-define user-initial-syntax-table 'DEFINE-METHOD
  283.   (macro e
  284.     (let ((class-name (caar e))
  285.           (method-name (cadar e))
  286.           (formal-list (cadr e))
  287.           (body (cddr e)))
  288.       `(%sc-class-add-method
  289.     ',class-name
  290.     ',method-name
  291.     ',class-name
  292.     ',class-name
  293.     (append (list 'lambda ',formal-list) ',body)
  294.     (lambda (env quoted-val)
  295.       (let* ((method-name ',method-name)
  296.          (temp `(in-package ,env 
  297.               (define ,method-name
  298.                 ,quoted-val))))
  299.         (eval temp (the-environment)))
  300.       )))))
  301. ;;;
  302.  
  303. (define %sc-class-add-method
  304.   (lambda (class-name
  305.        method-name
  306.        method-class
  307.        mixin-class
  308.        method
  309.        assigner)
  310.     (let ((class (%sc-name->class class-name)))
  311.       (begin
  312.     (let ((temp (assq method-name (%sc-method-values class))))
  313.       (if temp
  314.           (set-cdr! temp method)
  315.           (%sc-set-method-values 
  316.            class
  317.            (cons (cons method-name method) (%sc-method-values class))))))
  318.       (%compiled-add-method class-name method-name method-class mixin-class
  319.                 method assigner))))
  320. ;;;
  321.  
  322. (define %inform-subclasses
  323.   (lambda (class-name method-name method-class mixin-class method assigner)
  324.     ((rec loop
  325.        (lambda (class-name method-name method-class mixin-class
  326.                                        method assigner subclass)
  327.          (if subclass
  328.              (begin
  329.                 (%compiled-add-method
  330.                   (car subclass) method-name method-class class-name
  331.                   method assigner)
  332.                 (loop class-name method-name method-class mixin-class
  333.                       method assigner
  334.                       (cdr subclass))))))
  335.      class-name method-name method-class mixin-class method assigner
  336.      (%sc-subclasses (%sc-name->class class-name)))))
  337. ;;;
  338.  
  339. (define %compiled-add-method
  340.   (lambda (class-name
  341.        method-name
  342.        method-class
  343.        mixin-class
  344.        method
  345.        assigner)
  346.     (letrec
  347.       ((class (%sc-name->class class-name))
  348.  
  349.        (insert-entry
  350.          (lambda (previous current)
  351.            (cond ((null? current)
  352.                   (set-cdr! previous
  353.                      (cons (cons method-class mixin-class) '())))
  354.                  ((eq? mixin-class (cdar current))
  355.                   (set-car! (car current) method-class))
  356.                  ((%before mixin-class (cdar current)
  357.                            class-name)
  358.                   (set-cdr! previous
  359.                      (cons (cons method-class mixin-class) current)))
  360.                  (else '()))))
  361.  
  362.  
  363.        (loop-insert
  364.          (lambda (previous current)
  365.            (if (not (insert-entry previous current))
  366.                (loop-insert (current) (cdr current)))))
  367.  
  368.        (insert
  369.          (lambda (entry)
  370.            (if (insert-entry entry (cdr entry))  ;;; insert at head
  371.                (add-to-environment)
  372.                (loop-insert (cdr entry) (cddr entry)))))
  373.  
  374.        (add-to-environment
  375.          (lambda ()
  376.      (begin
  377.            (if (%sc-class-compiled class)
  378.                 (assigner (%sc-method-env class) method))
  379.            (if (%sc-subclasses class)
  380.                (%inform-subclasses class-name method-name method-class
  381.                                   mixin-class method assigner)))))
  382.  
  383.        (add-entry
  384.          (lambda ()
  385.      (begin
  386.            (%sc-set-method-structure class
  387.              (cons (list method-name (cons method-class mixin-class))
  388.                    (%sc-method-structure class)))
  389.            (add-to-environment))))
  390.       )
  391.  
  392.       (let ((method-entry (assq method-name (%sc-method-structure class))))
  393.         (if method-entry
  394.             (insert method-entry)
  395.             (add-entry))
  396.         method-name))))
  397. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  398. ;;;                                                                 ;;;
  399. ;;;                     S c o o p s                                 ;;;
  400. ;;;                                                                 ;;;
  401. ;;;                                                                 ;;;
  402. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  403. ;;;        by Steve Sherin--U of P                    ;;;
  404. ;;;                   File : meth2.scm                              ;;;
  405. ;;;                                                                 ;;;
  406. ;;;                 Amitabh Srivastava                              ;;;
  407. ;;;                                                                 ;;;
  408. ;;;    This file handles the deletion of a method from a class.     ;;;
  409. ;;;                                                                 ;;;
  410. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  411.  
  412. ;;; DELETE-METHOD 
  413. (syntax-table-define user-initial-syntax-table 'DELETE-METHOD 
  414.   (macro e
  415.     (let ((class-name (caar e))
  416.           (method-name (cadar e)))
  417.       `(%sc-class-del-method
  418.     ',class-name
  419.     ',method-name
  420.     ',class-name
  421.     ',class-name
  422.     (LAMBDA (ENV VAL)
  423.       (SET! (ACCESS ,method-name ENV) VAL))
  424.     #!false))))
  425. ;;;
  426.  
  427. (define %deleted-method
  428.   (lambda (name)
  429.     (lambda args
  430.       (error-handler name 3 #!TRUE))))
  431. ;;;
  432.  
  433. (define %sc-class-del-method
  434.   (lambda (class-name method-name method-class mixin-class assigner del-value)
  435.     (let ((class (%sc-name->class class-name)))
  436.       (let ((temp (assq method-name (%sc-method-values class))))
  437.     (if temp
  438.      (begin
  439.           (%sc-set-method-values class
  440.                (delq! temp (%sc-method-values class)))
  441.           (%compiled-del-method class-name method-name method-class mixin-class
  442.                                assigner del-value))
  443.  
  444.     (error-handler method-name 4 #!true))))))
  445. ;;;
  446.  
  447. (define %inform-del-subclasses
  448.   (lambda (class-name method-name method-class mixin-class assigner del-value)
  449.     ((rec loop
  450.        (lambda (class-name method-name method-class mixin-class assigner
  451.                 del-value subclass)
  452.          (if subclass
  453.              (begin
  454.                 (%compiled-del-method (car subclass) method-name
  455.                           method-class class-name assigner del-value)
  456.                 (loop class-name method-name method-class mixin-class assigner
  457.                       del-value (cdr subclass))))))
  458.      class-name method-name method-class mixin-class assigner del-value
  459.      (%sc-subclasses (%sc-name->class class-name)))))
  460. ;;;
  461.  
  462. (define %compiled-del-method
  463.   (lambda (class-name method-name method-class mixin-class assigner del-value)
  464.     (let ((class (%sc-name->class class-name)))
  465.       (letrec
  466.         ((delete-entry
  467.            (lambda (previous current)
  468.              (cond ((eq? mixin-class (cdar current))
  469.                     (set-cdr! previous (cdr current)) #!TRUE)
  470.                    (else #!FALSE))))
  471.  
  472.          (loop-delete
  473.            (lambda (previous current)
  474.              (cond ((or (null? current)
  475.                         (%before mixin-class (cdar previous)
  476.                                  class-name))
  477.                     (error-handler method-name 4 #!TRUE))
  478.                    ((delete-entry previous current) #!TRUE)
  479.                    (else (loop-delete current (cdr current))))))
  480.  
  481.          (delete
  482.            (lambda (entry)
  483.              (if (delete-entry entry (cdr entry))  ;;; delete at head
  484.                  (modify-environment entry)
  485.                  (loop-delete (cdr entry) (cddr entry)))))
  486.  
  487.        (modify-environment
  488.          (lambda (entry)
  489.        (cond ((null? (cdr entry))
  490.           (%sc-set-method-structure class
  491.             (delq! (assq method-name (%sc-method-structure class))
  492.                (%sc-method-structure class)))
  493.                   (if (%sc-class-compiled class)
  494.                       (assigner (%sc-method-env class)
  495.                                 (or del-value
  496.                                     (set! del-value
  497.                                           (%deleted-method method-name)))))
  498.           (if (%sc-subclasses class)
  499.               (%inform-del-subclasses class-name method-name
  500.                    method-class mixin-class assigner del-value)))
  501.          (else
  502.           (let ((meth-value
  503.              (%sc-get-meth-value method-name
  504.                          (%sc-name->class (caadr entry)))))
  505.             (if (%sc-class-compiled class)
  506.             (assigner (%sc-method-env class) meth-value))
  507.             (if (%sc-subclasses class)
  508.             (%inform-subclasses class-name
  509.                         method-name
  510.                         method-class
  511.                         mixin-class
  512.                         meth-value assigner)))))))
  513.       )
  514.  
  515.       (let ((method-entry (assq method-name (%sc-method-structure class))))
  516.         (if method-entry
  517.             (delete method-entry)
  518.             (error-handler method-name 4 #!TRUE))
  519.         method-name)))))
  520. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  521. ;;;                                                                 ;;;
  522. ;;;                     S c o o p s                                 ;;;
  523. ;;;                                                                 ;;;
  524. ;;;                                                                 ;;;
  525. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  526. ;;;        by Steve Sherin--U of P                    ;;;
  527. ;;;                   File : instance.scm                           ;;;
  528. ;;;                                                                 ;;;
  529. ;;;                 Amitabh Srivastava                              ;;;
  530. ;;;                                                                 ;;;
  531. ;;;    This file contains compiling and making of an instance.      ;;;
  532. ;;;                                                                 ;;;
  533. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  534.  
  535. ;;; COMPILE-CLASS
  536. (syntax-table-define user-initial-syntax-table 'COMPILE-CLASS
  537.   (macro e
  538.     `(let* ((class ,(car e))
  539.         (name (%sc-name class)))
  540.        (if (%sc-class-compiled class)
  541.        name
  542.        (begin
  543.          (%inherit-method-vars class)
  544.          (eval (%make-template name class) (the-environment)))))))
  545. ;;;
  546.  
  547. (define (%sc-compile-class class)
  548.   (begin
  549.     (%inherit-method-vars class)
  550.     (eval (%make-template (%sc-name class) class)
  551.         user-initial-environment)))
  552.  
  553. ;;; MAKE-INSTANCE
  554. (syntax-table-define user-initial-syntax-table 'MAKE-INSTANCE 
  555.   (macro e
  556.     (cons (list '%sc-inst-template (car e)) (cdr e))))
  557. ;;;
  558.  
  559. (define %uncompiled-make-instance
  560.   (lambda (class)
  561.     (lambda init-msg
  562.       (%sc-compile-class class)
  563.       (apply (%sc-inst-template class) init-msg))))
  564. ;;;
  565.  
  566. (define %make-template
  567.   (lambda (name class)
  568.     `(begin
  569. ;;; do some work to make compile-file work
  570.        (%sc-set-allcvs ,name ',(%sc-allcvs class))
  571.        (%sc-set-allivs ,name ',(%sc-allivs class))
  572.        (%sc-set-method-structure ,name
  573.             ',(%sc-method-structure class))
  574. ;;; prepare make-instance template
  575.        (%sc-set-inst-template ,name
  576.           ,(%make-inst-template (%sc-allcvs class)
  577.                                (%sc-allivs class)
  578.                                (%sc-method-structure class)
  579.                                name class))
  580.        (%sc-method-thrust ,name)
  581.        (%sc-set-class-compiled ,name #!TRUE)
  582.        (%sc-set-class-inherited ,name #!TRUE)
  583.        (%sign-on ',name ,name)
  584.        ',name)))
  585. ;;;
  586.  
  587. (define %make-inst-template
  588.   (lambda (cvs ivs method-structure name class)
  589.     (let ((methods '((%*methods*% '-)))
  590.           (classvar (append cvs '((%*classvars*% '-))))
  591.           (instvar  (append ivs '((%*instvars*% '-)))))
  592. ;;; dummy variables are added to methods, cvs, and ivs to prevent the
  593. ;;; compiler from folding them away.
  594.          `(let ,classvar
  595.            (%sc-set-class-env ,name (the-environment))
  596.             (let ,methods
  597.               (%sc-set-method-env ,name (the-environment))
  598.           (let ((%sc-class ,name))
  599.               (lambda %sc-init-vals
  600.                 (let ,instvar
  601.                   (the-environment)))))))))
  602.  
  603.  
  604.  
  605. ;;; %sc-method-thrust evaluates each method in the method-environment
  606. ;;; for the class, enabling methods to grab free variables from the
  607. ;;; class-environment without a special code-replacement call.
  608.  
  609. (define (%sc-method-thrust class)
  610.   (define (iter binding-pair)
  611.     (let* ((method-name (car binding-pair))
  612.        (quoted-val (cdr binding-pair))
  613.        (temp `(in-package (%sc-method-env class)
  614.             (define ,method-name ,quoted-val))))
  615.       (eval temp (the-environment))))
  616. (mapcar iter (%sc-method-values class)))
  617.  
  618.  
  619.  
  620. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  621. ;;;                                                                 ;;;
  622. ;;;                     S c o o p s                                 ;;;
  623. ;;;                                                                 ;;;
  624. ;;;                                                                 ;;;
  625. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  626. ;;;        by Steve Sherin--U of P                    ;;;
  627. ;;;                   File : inht.scm                               ;;;
  628. ;;;                                                                 ;;;
  629. ;;;                 Amitabh Srivastava                              ;;;
  630. ;;;                                                                 ;;;
  631. ;;;    This file contains routines to handle inheritance.           ;;;
  632. ;;;                                                                 ;;;
  633. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  634.  
  635. ;;;
  636.  
  637. (define %inherit-method-vars
  638.   (lambda (class)
  639.     (or (%sc-class-inherited class)
  640.     (%inherit-from-mixins
  641.      (%sc-allcvs class)
  642.      (%sc-allivs class)
  643.      (%sc-method-structure class)
  644.      (%sc-mixins class)
  645.      class
  646.      (lambda (class cvs ivs methods)
  647.        (%sc-set-allcvs class cvs)
  648.        (%sc-set-allivs class ivs)
  649.        (%sc-set-method-structure class methods)
  650.            (%sc-set-class-inherited class #!true)
  651.            (%sign-on (%sc-name class) class)
  652.        class)))))
  653. ;;;
  654.  
  655. (define %sign-on
  656.   (lambda (name class)
  657.     (mapcar
  658.       (lambda (mixin)
  659.         (let* ((mixin-class (%sc-name->class mixin))
  660.                (subc (%sc-subclasses mixin-class)))
  661.           (if (not (%sc-class-inherited mixin-class))
  662.               (%inherit-method-vars mixin-class))
  663.           (or (memq name subc)
  664.               (%sc-set-subclasses mixin-class (cons name subc)))))
  665.       (%sc-mixins class))))
  666. ;;;
  667.  
  668. (define %inherit-from-mixins
  669.   (letrec
  670.     ((insert-entry
  671.       (lambda (entry class1 method-entry name2 previous current)
  672.         (cond ((null? current)
  673.                (set-cdr! previous
  674.                          (cons (cons (caadr method-entry) name2) '())))
  675.               ((%before name2 (cdar current) (%sc-name class1))
  676.                (set-cdr! previous
  677.                          (cons (cons (caadr method-entry) name2) current)))
  678.               (else '()))))
  679.  
  680.     (insert
  681.       (lambda (struct1 entry class1 struct2 name2)
  682.         ((rec loop-insert
  683.            (lambda (struct1 entry class1 struct2 name2 previous current)
  684.              (if (insert-entry entry class1 struct2 name2 previous current)
  685.                  struct1
  686.                  (loop-insert struct1 entry class1 struct2 name2
  687.                               current (cdr current)))))
  688.          struct1 entry class1 struct2 name2 entry (cdr entry))))
  689.  
  690.     (add-entry
  691.       (lambda (struct1 class1 method-entry name2)
  692.         (cons (list (car method-entry) (cons (caadr method-entry) name2))
  693.               struct1)))
  694.  
  695.     (combine-methods
  696.       (lambda (struct1 class1 struct2 name2)
  697.     (if struct2
  698.         (combine-methods
  699.          (let ((entry (assq (caar struct2) struct1)))
  700.            (if entry
  701.            (insert struct1 entry class1 (car struct2) name2)
  702.            (add-entry struct1 class1 (car struct2) name2)))
  703.          class1
  704.          (cdr struct2)
  705.          name2)
  706.         struct1)))
  707.  
  708.      (combine-vars
  709.        (lambda (list1 list2)
  710.      (if list2
  711.          (combine-vars
  712.           (if (assq (caar list2) list1)
  713.           list1
  714.           (cons (car list2) list1))
  715.           (cdr list2))
  716.          list1)))
  717.      )
  718.  
  719.   (lambda (cvs ivs methods mixins class receiver)
  720.     ((rec loop-mixins
  721.        (lambda (cvs ivs methods mixins class receiver)
  722.          (if mixins
  723.              (let ((mixin-class (%sc-name->class (car mixins))))
  724.                (%inherit-method-vars mixin-class)
  725.                (loop-mixins
  726.                  (combine-vars cvs (%sc-allcvs mixin-class))
  727.                  (combine-vars ivs (%sc-allivs mixin-class))
  728.                  (combine-methods methods class
  729.                           (%sc-method-structure mixin-class) (car mixins))
  730.                  (cdr mixins)
  731.                  class
  732.                  receiver))
  733.              (receiver class cvs ivs methods ))))
  734.      cvs ivs methods mixins class receiver))))
  735.  
  736. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  737. ;;;                                                                 ;;;
  738. ;;;                     S c o o p s                                 ;;;
  739. ;;;                                                                 ;;;
  740. ;;;                                                                 ;;;
  741. ;;;        Rewritten 5/20/87 for cscheme                            ;;;
  742. ;;;        by Steve Sherin--U of P                                  ;;;
  743. ;;;                   File : interf.scm                             ;;;
  744. ;;;                                                                 ;;;
  745. ;;;                 Amitabh Srivastava                              ;;;
  746. ;;;                                                                 ;;;
  747. ;;;    This file contains class definition and processing of        ;;;
  748. ;;;    define-class.                                                ;;;
  749. ;;;                                                                 ;;;
  750. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  751.  
  752. ;;; DEFINE-CLASS
  753. (syntax-table-define user-initial-syntax-table 'DEFINE-CLASS
  754.   (macro e
  755.     (let ((name (car e)) 
  756.       (classvars '()) 
  757.       (instvars '()) (mixins '())
  758.           (options '())
  759.       (allvars '())
  760.       (method-values '())(inits '()))
  761.       (letrec
  762.       ((chk-class-def
  763.         (lambda (deflist)
  764.           (if deflist
  765.           (begin
  766.             (cond ((eq? (caar deflist) 'classvars)
  767.                (set! classvars (cdar deflist)))
  768.               ((eq? (caar deflist) 'instvars)
  769.                (set! instvars (cdar deflist)))
  770.               ((eq? (caar deflist) 'mixins)
  771.                (set! mixins (cdar deflist)))
  772.               ((eq? (caar deflist) 'options)
  773.                (set! options (cdar deflist)))
  774.               (else (error-handler (caar deflist) 0 '())))
  775.             (chk-class-def (cdr deflist)))
  776.           (update-allvars))))
  777.  
  778.        (update-allvars
  779.         (lambda ()
  780.           (set! allvars
  781.             (append (mapcar (lambda (a) (if (symbol? a) a (car a)))
  782.                     classvars)
  783.                 (mapcar (lambda (a) (if (symbol? a) a (car a)))
  784.                     instvars)))))
  785.  
  786.  
  787.        (chk-option
  788.         (lambda (opt-list)
  789.           (let loop ((opl opt-list)(meths '()))
  790.         (if opl
  791.             (loop
  792.              (cdr opl)
  793.              (cond ((eq? (caar opl) 'gettable-variables)
  794.                 (append (generate-get (cdar opl)) meths))
  795.                ((eq? (caar opl) 'settable-variables)
  796.                 (append (generate-set (cdar opl)) meths))
  797.                ((eq? (caar opl) 'inittable-variables)
  798.                 (set! inits (cdar opl)) meths)
  799.                (else (error-handler (car opl) 1 '()))))
  800.             meths))))
  801.  
  802.        (chk-cvs
  803.         (lambda (list-var)
  804.           (mapcar
  805.            (lambda (a)
  806.          (if (symbol? a)
  807.              (list a #!false)
  808.              a))
  809.            list-var)))
  810.  
  811.        (chk-init
  812.         (lambda (v-form)
  813.           (if (memq (car v-form) inits)
  814.           `(,(car v-form)
  815.             (let ((temp (memq ',(car v-form) %sc-init-vals)))
  816.                     ;was '%sc-init-vals
  817.               (if temp (cadr temp)
  818.               ,(cadr v-form))))
  819.           v-form)))
  820.  
  821.        (chk-ivs
  822.         (lambda (list-var)
  823.           (mapcar
  824.            (lambda (var)
  825.          (chk-init
  826.           (cond ((symbol? var) (list var #!false))
  827.                         ((not-active? (cadr var)) var)
  828.                         (else (active-val (car var) (cadr var))))))
  829.            list-var)))
  830.  
  831.        (not-active?
  832.         (lambda (a)
  833.           (or (not (pair? a))
  834.           (not (eq? (car a) 'active)))))
  835.  
  836.        (empty-slot?
  837.         (lambda (form)
  838.           (cond
  839.            ((symbol? form) #f)
  840.            ((eq? form #f) #t)
  841.            (else #f))))
  842.  
  843.        (active-val
  844.         (lambda (var active-form)
  845.           (let loop ((var var)(active-form active-form)
  846.                   (getfns '())(setfns '%sc-val))
  847.         (if (not-active? (cadr active-form))
  848.             (create-active
  849.              var
  850.              (if (empty-slot? (caddr active-form))
  851.              getfns
  852.              (cons (caddr active-form) getfns))
  853.              (list 'set! var
  854.                (if (empty-slot? (cadddr active-form))
  855.                    setfns
  856.                    (list (cadddr active-form) setfns)))
  857.              (cadr active-form))
  858.             (loop
  859.              var
  860.              (cadr active-form)
  861.              (if (empty-slot? (caddr active-form))
  862.              getfns
  863.              (cons (caddr active-form) getfns))
  864.              (if (empty-slot? (cadddr active-form))
  865.              setfns
  866.              (list (cadddr active-form) setfns)))))))
  867.  
  868.        (create-active
  869.         (lambda (var getfns setfns localstate)
  870.           (begin
  871.         (set! method-values
  872.               (cons `(CONS ',(concat "GET-" var)
  873.                    (list 'lambda '() ',(expand-getfns var getfns)))
  874.                 (cons `(CONS ',(concat "SET-" var)
  875.                      (list 'lambda (list '%sc-val)
  876.                            ',setfns))
  877.                   method-values)))
  878.         (list var localstate))))
  879.  
  880.        (expand-getfns
  881.         (lambda (var getfns)
  882.           (let loop ((var var)(gets getfns)(exp-form var))
  883.         (if gets
  884.             (loop
  885.              var
  886.              (cdr gets)
  887.              (list (car gets) exp-form))
  888.             exp-form))))
  889.        (concat
  890.         (lambda (str sym)
  891.           (string->symbol (string-append str (symbol->string sym)))))
  892.  
  893.        (generate-get
  894.         (lambda (getlist)
  895.           (mapcar
  896.            (lambda (a)
  897.          `(CONS ',(concat "GET-" a)
  898.             (list 'lambda '()
  899.                   ',a)))
  900.            getlist)))
  901.  
  902.        (generate-set
  903.         (lambda (setlist)
  904.           (mapcar
  905.            (lambda (a)
  906.          `(CONS ',(concat "SET-" a)
  907.             (list 'lambda (list '%sc-val)
  908.                   (list 'set! ',a '%sc-val))))
  909.            setlist)))
  910.  
  911.        )
  912.  
  913. ;; define-class begins here.
  914.  
  915.     (begin
  916.       (chk-class-def (cdr e))
  917.       (set! method-values
  918.         (chk-option
  919.          (mapcar (lambda (a) (if (symbol? a) (cons a allvars) a))
  920.              options)))
  921.       (set! instvars (and instvars (chk-ivs instvars)))
  922. ;; Evaluate here so that active-value functions are generated properly.
  923. ;; --Steve Sherin
  924.       (set! classvars (and classvars (chk-cvs classvars)))
  925.       (eval
  926.        `(DEFINE ,name
  927.           (%SC-MAKE-CLASS
  928.            ',name
  929.            ',classvars
  930.            ',instvars
  931.            ',mixins
  932.            ,(and method-values (cons 'list method-values))
  933.            ))
  934.        user-initial-environment)
  935.       )))))
  936. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  937. ;;;                                                                 ;;;
  938. ;;;                     S c o o p s                                 ;;;
  939. ;;;                                                                 ;;;
  940. ;;;                                                                 ;;;
  941. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  942. ;;;        by Steve Sherin--U of P                    ;;;
  943. ;;;                   File : send.scm                               ;;;
  944. ;;;                                                                 ;;;
  945. ;;;                 Amitabh Srivastava                              ;;;
  946. ;;;                                                                 ;;;
  947. ;;;-----------------------------------------------------------------;;;
  948. ;;;    One does not have to use the SEND form to invoke methods     ;;;
  949. ;;;    in the same class; they can be invoked as Scheme functions.  ;;;
  950. ;;;                                                                 ;;;
  951. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  952.  
  953. ;;; SEND
  954. (syntax-table-define user-initial-syntax-table 'SEND
  955.   (macro e
  956.  
  957.     (let ((args (cddr e))
  958.       (msg (cadr e))
  959.       (obj (car e)))
  960.       `(let* ((set-parent! (access ic-environment/set-parent!
  961.                    environment-package))
  962.           (ep environment-parent)
  963.           (ibot ,obj)
  964.           (itop (ep (ep ibot)))
  965.           (ipar (ep itop))
  966.           (class (access %sc-class ibot))
  967.           (ctop (%sc-class-env class))
  968.           (cpar (ep ctop))
  969.           (cbot (%sc-method-env class))
  970.           (instance-safe? (eq? ipar cbot)))
  971.  
  972.      (without-interrupts
  973.       (lambda ()
  974.         (dynamic-wind
  975.          (lambda ()
  976.            (set-parent! ctop ibot)
  977.            (if instance-safe?
  978.            (set-parent! itop cpar)))
  979.  
  980.  
  981.          (lambda ()
  982.            (in-package cbot (,msg ,@args)))
  983.  
  984.          (lambda ()
  985.            (set-parent! ctop cpar)
  986.            (set-parent! itop cbot))
  987.          )))))))
  988.  
  989.  
  990. ;;; SEND-IF-HANDLES
  991. (syntax-table-define user-initial-syntax-table 'SEND-IF-HANDLES
  992.   (macro e
  993.     (let ((obj (car e))
  994.       (msg (cadr e))
  995.       (args (cddr e)))
  996.       `(let
  997.        ((self ,obj))
  998.  
  999.      (if (assq ',msg (%sc-method-structure (access %sc-class self)))
  1000.          (send self ,msg ,@args)
  1001.          #!false)))))
  1002.  
  1003.  
  1004.  
  1005. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1006. ;;;                                                                 ;;;
  1007. ;;;                     S c o o p s                                 ;;;
  1008. ;;;                                                                 ;;;
  1009. ;;;                                                                 ;;;
  1010. ;;;        Rewritten 5/20/87 for cscheme                ;;;
  1011. ;;;        by Steve Sherin--U of P                    ;;;
  1012. ;;;                   File : utl.scm                                ;;;
  1013. ;;;                                                                 ;;;
  1014. ;;;                 Amitabh Srivastava                              ;;;
  1015. ;;;                                                                 ;;;
  1016. ;;;    This file contains misc. routines                            ;;;
  1017. ;;;                                                                 ;;;
  1018. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1019.  
  1020.  
  1021. ;;;   Error handler. Looks up the error message in the table and
  1022. ;;;   prints it.
  1023.  
  1024. (define error-handler
  1025.   (let ((error-table
  1026.      (let ((table (make-vector 8)))
  1027.        (vector-set! table 0 " Invalid class definition ")
  1028.        (vector-set! table 1 " Invalid option ")
  1029.        (vector-set! table 2 " Class not defined ")
  1030.        (vector-set! table 3 " Method has been deleted ")
  1031.        (vector-set! table 4 " Method is not present ")
  1032.        (vector-set! table 5 " Variable is not present")
  1033.        (vector-set! table 6 " Not a Scoops Class")
  1034.        (vector-set! table 7 " Class not compiled ")
  1035.        table)))
  1036.     (lambda (msg number flag)
  1037.       (if flag
  1038.           (error (vector-ref error-table number) msg)
  1039.           (breakpoint (vector-ref error-table number) msg)))))
  1040.  
  1041.  
  1042. ;;;   some functions defined globally which will be moved locally later
  1043.  
  1044.         (define %sc-class-description
  1045.            (lambda (class)
  1046.               (writeln " ")
  1047.               (writeln "    CLASS DESCRIPTION    ")
  1048.               (writeln "    ==================    ")
  1049.               (writeln " ")
  1050.               (writeln " NAME            : " (%sc-name class))
  1051.               (writeln " CLASS VARS      : "
  1052.                        (mapcar car (%sc-allcvs class)))
  1053.               (writeln " INSTANCE VARS   : "
  1054.                        (mapcar car (%sc-allivs class)))
  1055.               (writeln " METHODS         : "
  1056.                        (mapcar car (%sc-method-structure class)))
  1057.               (writeln " MIXINS          : " (%sc-mixins class))
  1058.               (writeln " CLASS COMPILED  : " (%sc-class-compiled class))
  1059.               (writeln " CLASS INHERITED : " (%sc-class-inherited class))
  1060.            ))
  1061. ;;;
  1062.  
  1063.     (define %sc-inst-desc
  1064.        (lambda (inst)
  1065.          (letrec ((class (access %sc-class inst))
  1066.                   (printvars
  1067.                     (lambda (f1 f2)
  1068.               (if f1            ; another var
  1069.               (begin
  1070.                (writeln "   " (caar f1) " : "
  1071.                 (cadr (assq (caar f1) f2)))
  1072. ;; environment bindings in list form vs. pair form.  Steve Sherin
  1073.                (printvars (cdr f1) f2))
  1074.                 *the-non-printing-object*))))
  1075.             (writeln " ")
  1076.         (writeln "  INSTANCE DESCRIPTION      ")
  1077.         (writeln "  ====================      ")
  1078.         (writeln " ")
  1079.          (writeln "  Instance of Class :  " (%sc-name class))
  1080.         (writeln " ")
  1081.         (writeln "  Class Variables : ")
  1082.             (printvars (%sc-allcvs class)
  1083.                (environment-bindings (%sc-class-env class)))
  1084.             (writeln " ")
  1085.         (writeln "  Instance Variables :")
  1086.             (printvars (%sc-allivs class) (environment-bindings inst))
  1087.            )))
  1088.  
  1089. ;;;
  1090. (define %scoops-chk-class-compiled
  1091.   (lambda (name class)
  1092.     (or (%sc-class-compiled class)
  1093.         (error-handler name 7 #!true))))
  1094.  
  1095. ;;;
  1096. (define %sc-class-info
  1097.   (lambda (fn)
  1098.     (lambda (class)
  1099.       (%scoops-chk-class class)
  1100.       (mapcar car (fn class)))))
  1101.  
  1102. ;;; ALL-CLASSVARS
  1103. (set! all-classvars (%sc-class-info %sc-allcvs))
  1104.  
  1105. ;;; ALL-INSTVARS
  1106. (set! all-instvars (%sc-class-info %sc-allivs))
  1107.  
  1108. ;;; ALL-METHODS
  1109. (set! all-methods (%sc-class-info %sc-method-structure))
  1110.  
  1111. ;;; (CLASS-COMPILED? CLASS)
  1112. (set! class-compiled?
  1113.   (lambda (class)
  1114.     (%scoops-chk-class class)
  1115.     (%sc-class-compiled class)))
  1116.  
  1117. ;;; (CLASS-OF-OBJECT OBJECT)
  1118. (syntax-table-define user-initial-syntax-table 'CLASS-OF-OBJECT
  1119.   (macro e
  1120.     `(%sc-name (access %sc-class ,(car e)))))
  1121.  
  1122. ;;; CLASSVARS
  1123. (set! classvars (%sc-class-info %sc-cv))
  1124.  
  1125. ;;; DESCRIBE
  1126. (set! describe
  1127.   (lambda (class-inst)
  1128.     (if (vector? class-inst)
  1129.         (begin
  1130.           (%scoops-chk-class class-inst)
  1131.           (%sc-class-description class-inst))
  1132.         (%sc-inst-desc class-inst))))
  1133.  
  1134. ;;; (GETCV CLASS VAR)
  1135. (syntax-table-define user-initial-syntax-table 'GETCV 
  1136.   (macro e
  1137.     (let ((class (car e))
  1138.       (var (cadr e)))
  1139.       `(begin
  1140.          (and (%sc-name->class ',class)
  1141.               (%scoops-chk-class-compiled ',class ,class))
  1142.      ((access ,(%sc-concat "GET-" var) (%sc-method-env ,class)))))))
  1143.  
  1144. ;;; INSTVARS
  1145. (set! instvars (%sc-class-info %sc-iv))
  1146.  
  1147. ;;; METHODS
  1148. (set! methods (%sc-class-info %sc-method-values))
  1149.  
  1150. ;;; MIXINS
  1151. (set! mixins
  1152.   (lambda (class)
  1153.     (%scoops-chk-class class)
  1154.     (%sc-mixins class)))
  1155.  
  1156. ;;; (NAME->CLASS NAME)
  1157. (syntax-table-define user-initial-syntax-table 'NAME->CLASS
  1158.   (macro e
  1159.     `(%sc-name->class ,(car e))))
  1160.  
  1161. ;;; (RENAME-CLASS (CLASS NEW-NAME))
  1162. (syntax-table-define user-initial-syntax-table 'RENAME-CLASS
  1163.   (macro e
  1164.     (let ((class (caar e))
  1165.       (new-name (cadar e)))
  1166.       `(begin
  1167.      (%sc-name->class ',class)
  1168.      (%sc-set-name ,class ',new-name)
  1169.      (putprop ',new-name ,class '%class)
  1170.      (eval (define ,new-name ,class) user-initial-environment)
  1171.      ',new-name))))
  1172.  
  1173. ;;; (SETCV CLASS VAR VAL)
  1174. (syntax-table-define user-initial-syntax-table 'SETCV
  1175.   (macro e
  1176.     (let ((class (car e))
  1177.       (var (cadr e))
  1178.       (val (caddr e)))
  1179.       `(begin
  1180.          (and (%sc-name->class ',class)
  1181.               (%scoops-chk-class-compiled ',class ,class))
  1182.      ((access ,(%sc-concat "SET-" var) (%sc-method-env ,class)) ,val)))))
  1183.